perm filename M11B.F4[M11,LCS]5 blob sn#418017 filedate 1979-02-10 generic text, type T, neo UTF8
00100	CGEN1      FUNCTION GENERATOR 1 
00200	C    *** MUSIC V ***     
00300	      SUBROUTINEGEN1     
00400	      COMMON I(1)/P/ P(1) /GENS/GENS(1)
00500		1 /LFUNC/LFUNC
00600	      N1=1+(IFIX(P(4))-1)*LFUNC     
00700	      M1=7 
00800	 102  M=M1+1
00900	      IF(P(M).LE.0)GO TO 103
01000	      V1=P(M1-2)
01100	      V2=(P(M1)-P(M1-2))/(P(M)-P(M1-1))
01200	      MA=N1+IFIX(P(M1-1))
01300	      MB=N1+IFIX(P(M))-1     
01400	      DO 101 J=MA,MB
01500	      XJ=J-MA     
01600	 101  GENS(J)=V1+V2*XJ      
01700	      IF(IFIX(P(M)).EQ.(LFUNC-1))GO TO 103   
01800	      M1=M1+2     
01900	      GO TO 102     
02000	 103  GENS(MB+1)=P(M1)
02100	      RETURN      
02200	      END  
02300	
02400	CGEN2      FUNCTION GENERATOR 2 
02500	C    *** MUSIC V ***     
02600	      SUBROUTINEGEN2     
02700	      COMMON I(1)/P/ P(1) /GENS/GENS(1)
02800		1 /LFUNC/LFUNC
02900	      N1=1+(IFIX(P(4))-1)*LFUNC    
03000	      N2=N1+LFUNC-1      
03100	      DO 101 K1=N1,N2      
03200	 101  GENS(K1)=0.0   
03300	      FAC=6.283185/(FLOAT(LFUNC)-1.0)  
03400	      NMAX=I(1)   
03500	      N3=5+INT(ABS(P(NMAX)))-1  
03600	      IF(N3-5.LT.0)GO TO 104
03700	      DO 103 J=5,N3 
03800	      FACK=FAC*FLOAT(J-4)
03900	      DO 102 K=N1,N2
04000	 102  GENS(K)=GENS(K)+SIN(FACK*FLOAT(K-N1))*P(J)    
04100	 103  CONTINUE    
04200	 104  N4=N3+1     
04300	      N5=I(1)-1   
04400	      IF(N5-N4.LT.0)GO TO 114
04500	      DO 107 J1=N4,N5      
04600	      FACK=FAC*FLOAT(J1-N4)     
04700	      DO 106 K1=N1,N2      
04800	 106  GENS(K1)=GENS(K1)+COS(FACK*FLOAT(K1-N1))*P(J1)
04900	 107  CONTINUE    
05000	114   IF(P(NMAX).LE.0)GO TO 112
05100	      FMAX=0.0    
05200	      DO 110  K2=N1,N2      
05300	      A=ABS(GENS(K2))
05400	110   IF(FMAX.LT.A)FMAX=A
05500	 113  DO 111 K3=N1,N2      
05600	 111  GENS(K3)=GENS(K3)/FMAX  
05700	      RETURN      
05800	112   FMAX=.99999 
05900	      GO TO 113     
06000	      END  
06100	
06200	CPARM      CONTROL DATA SPECIFICATION FOR PASS 3     
06300	C    *** MUSIC V ***     
06400	C   
06500	C     IP(1) = NUMBER OF OP CODES
06600	C     IP(2) = BEGINNING SUBSCRIPT OF FIRST FUNCTION  
06700	C     IP(3) = STANDARD SAMPLING RATE   
06800	C     IP(4) = BEGINNING SUBSCRIPT OF INSTRUMENT DEFINITIONS 
06900	C     IP(5) = BEGINNING OF LOCATION TABLE FOR INSTRUMENT DEFINITIONS      
07000	C     IP(6) = LENGTH OF FUNCTIONS      
07100	C     IP(7) = BEGINNING OF NOTE CARD PARAMETERS      
07200	C     IP(8) = LENGTH OF NOTE CARD PARAMETER BLOCKS   
07300	C     IP(9) = NUMBER OF NOTE CARD PARAMETER BLOCKS   
07400	C     IP(10)= BEGINNING OF OUTPUT DATA BLOCK  
07500	C     IP(11)= SOUND ZERO (SILENCE VALUE)      
07600	C     IP(12)= SCALE FACTOR FOR NOTE CARD PARAMETERS  
07700	C     IP(13)= BEGINNING OF GENERATOR INPUT-OUTPUT BLOCKS    
07800	C     IP(14)= LENGTH OF GENERATOR INPUT-OUTPUT BLOCKS
07900	C     IP(15)= SCALE FACTOR FOR FUNCTIONS      
08000	C   
08100	CS    BLOCK DATA  
08200	CS    COMMON /PARM/IP(20)
08300	CS    DATA IP/12,512,10000, 7100, 7000,512, 6000,35,27,4487,2048,  
08400	CS   1   10     ,4487,512,  "77777  ,5*0/
08500	CCC   DATA IP/12,512,10000,14500,14400,512,13000,35,40,6657,2048,  
08600	CCC  1  "1000000,6657,512,"377777777777,5*0/
08700	C*****BIG NUMB. IS IBM360'S BIGGEST.  1  65536,6657,512,Z7FFFFFFF/      
08800	CS    END  
08900	
09000	
09100	CDSMOUT   DEBUG SAMOUT     'C////'=CHANGES FOR PDP11 VERSION
09200	C *** MUSIC V *** 
09300	C     DEBUG SAMOUT
09400	      SUBROUTINE SAMOUT(IDSK,N)    
09500		COMMON I(1)  /ROUT/ROUT(1)  /FINOUT/PEAK,IPEAK,NBUF
09600		1 /CONV/CONV,INIOUT,JFLNM
09700	      DIMENSION IDBUF(2048),JDBUF(512),NN(512),LDBUF(512)
09800	 	EQUIVALENCE (IDBUF,JDBUF),(LDBUF,IDBUF(513))
09900	C*** IDBUF WILL STORE PACKED SAMPLES. ****
10000	CSS      INTEGER PEAK
10100		IF(INIOUT.EQ.0)GO TO 99
10200	C NOW OPEN PROPER OUTPUT FILE
10300		INIOUT=0
10400		IDSK=0
10500		IF(CONV.EQ.0)GO TO 199
10600	C		CALL PUTFILE('11')
10700		CALL PUTEXT('TEST','SND')
10800		NN(1)="525252525252
10900		NN(2)=I(4)
11000	C I(4)=SRATE, I(8)=NCHNS(-1),  FOR NEXT, 0=12 BIT, 1=18 BIT SMPLS.
11100		NN(3)="3000001
11200		NN(4)=I(8)+1
11300	  	NN(5)=64000
11400		DO 299 K=6,128
11500	299	NN(K)=0
11600	C	CALL FASTOU(NN,128)
11700		CALL EXTOUT(NN,128)
11800		GO TO 99
11900	C  OUTPUT IS ALWAYS NAMED 'TEST.DAT' FOR NOW.
12000	CX199X	CALL OPEN(23,'TEST',0,'NEW',,,'UNF')
12100	199   	CALL OFILE(23,'TEST')
12200	99    J=IDSK+1
12300		M1=1
12400	      M2=0
12500	      IDSK=IDSK+N
12600	C  COUNTS SAMPLES TO DATE
12700	      DO 1 K=J,IDSK
12800	      S=ROUT(M1+M2)
12900		A=ABS(S)
13000	      IF(A.GT.PEAK)PEAK=A
13100	    	IF(CONV.NE.0)S=S*64.
13200	C *64 TO CONVERT 12 BIT AMPL RANGE TO 16 BIT RANGE.
13300	      IDBUF(K)=S
13400	1     M2=M2+1
13500	      IF(IDSK.LT.NBUF)RETURN
13600	C NBUF=512,MONO   =1024,STEREO
13700	
13800		IF(CONV.EQ.0)GO TO 11
13900		M=1
14000		J=NBUF/2
14100		DO 44 K=1,J
14200	
14300	   	NN(K)=(IDBUF(M)*"1000000).OR.(IDBUF(M+1).AND."777777)
14400	C  PACKS 2 SMPLS PER WORD.
14500	CC	NN(K)=IDBUF(M)*262144+IDBUF(M+1)
14600	C 16*262144=4194304
14700	44	M=M+2
14800	
14900	CZ     IF(MS(L).LT.0)MS(L)=4096+MS(L)
15000	CZ      IDBUF(KL)=MS(3)+MS(2)*4096+MS(1)*16777216
15100	C PACKS 3 SMPLS TO A 36-BIT WORD. 4096=2**12, 16---=2**24.
15200	C  MS(1) HAS LEFT HAND 12 BITS; MS(2), MIDDLE 12 BITS; MS(3), RIGHT 12.
15300	C  NEGATIVE NUMBERS RUN FROM 4095(I.E. -1) TO 2049(I.E. -2048).
15400	C	CALL FASTOU(NN,J)
15500		CALL EXTOUT(NN,J)
15600		GO TO 10
15700	
15800	11	WRITE(23)JDBUF
15900		IF(NBUF.NE.512)WRITE(23),LDBUF
16000	C ABOVE FOR STEREO
16100	10    J=IDSK-NBUF
16200	      IF(J.LT.1)GO TO 4
16300	      DO 5 K=1,J
16400	5     IDBUF(K)=IDBUF(NBUF+K)
16500	4     IDSK=J
16600	      RETURN
16700	      END  
16800	
16900	CERRO1     GENERAL ERROR ROUTINE
17000	C    *** MUSIC V ***     
17100	      SUBROUTINE ERROR(I) 
17150		COMMON /NDEV/NDEV
17200	      WRITE(NDEV,100),I  
17300	  100 FORMAT (' ERROR OF TYPE',I5/)     
17400	      RETURN      
17500	      END